home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / cl-nd-cl.lha / clue / clio / scroll-frame.lisp < prev    next >
Encoding:
Text File  |  1990-07-19  |  21.8 KB  |  647 lines
  1. ;;; -*- Mode:Lisp; Package:CLIO-OPEN; Base:10; Lowercase:T; Syntax:Common-Lisp -*-
  2.  
  3.  
  4. ;;;----------------------------------------------------------------------------------+
  5. ;;;                                                                                  |
  6. ;;;                          TEXAS INSTRUMENTS INCORPORATED                          |
  7. ;;;                                  P.O. BOX 149149                                 |
  8. ;;;                                AUSTIN, TEXAS 78714                               |
  9. ;;;                                                                                  |
  10. ;;;             Copyright (C) 1989, 1990 Texas Instruments Incorporated.             |
  11. ;;;                                                                                  |
  12. ;;; Permission is granted to any individual or institution to use, copy, modify, and |
  13. ;;; distribute this software, provided that  this complete copyright and  permission |
  14. ;;; notice is maintained, intact, in all copies and supporting documentation.        |
  15. ;;;                                                                                  |
  16. ;;; Texas Instruments Incorporated provides this software "as is" without express or |
  17. ;;; implied warranty.                                                                |
  18. ;;;                                                                                  |
  19. ;;;----------------------------------------------------------------------------------+
  20.  
  21. (in-package "CLIO-OPEN")
  22.  
  23. (export '(scroll-frame
  24.       make-scroll-frame
  25.       scroll-frame-area
  26.       scroll-frame-content
  27.       scroll-frame-horizontal
  28.       scroll-frame-left
  29.       scroll-frame-position
  30.       scroll-frame-reposition
  31.       scroll-frame-top
  32.       scroll-frame-vertical
  33.       ))
  34.  
  35.  
  36.  
  37. (defcontact scroll-frame (core composite)
  38.   ((horizontal               :type      switch
  39.                  :initform  :on
  40.                  :initarg   :horizontal
  41.                  :reader    scroll-frame-horizontal) ; setf defined below
  42.    (left             :type      integer
  43.                  :initform  0
  44.                  :initarg   :left
  45.                  :accessor  scroll-frame-left)
  46.    (top                      :type      integer
  47.                  :initform  0
  48.                  :initarg   :top
  49.                  :accessor  scroll-frame-top)
  50.    (vertical                 :type      switch
  51.                  :initform  :on
  52.                  :initarg   :vertical
  53.                  :reader    scroll-frame-vertical))     ; setf defined below
  54.   (:resources
  55.     (border-width :initform 0)
  56.     (content      :type (or function list) :initform nil)
  57.     horizontal
  58.     left
  59.     top
  60.     vertical)
  61.   (:documentation
  62.     "Provide horizontal and/or vertical scrolling controls for an arbitrary content contact"))
  63.  
  64.  
  65. ;;;----------------------------------------------------------------------------+
  66. ;;;                                                                            |
  67. ;;;                              Accessors                                     |
  68. ;;;                                                                            |
  69. ;;;----------------------------------------------------------------------------+
  70.  
  71.  
  72. (defmethod scroll-frame-content ((scroll-frame scroll-frame))
  73.   (first (composite-children (scroll-frame-area scroll-frame))))
  74.  
  75. (proclaim '(inline scroll-frame-hscroller))
  76. (defun scroll-frame-hscroller (scroll-frame)
  77.   (with-slots (children) scroll-frame
  78.     (find :hscroller children
  79.       :key #'contact-name
  80.       :test #'eq)))
  81.  
  82. (proclaim '(inline scroll-frame-vscroller))
  83. (defun scroll-frame-vscroller (scroll-frame)
  84.   (with-slots (children) scroll-frame
  85.     (find :vscroller children
  86.       :key #'contact-name
  87.       :test #'eq)))
  88.  
  89.  
  90. (defmethod scroll-frame-area ((scroll-frame scroll-frame))
  91.   (with-slots (children) scroll-frame
  92.     (find :scroll-area children
  93.       :key #'contact-name
  94.       :test #'eq)))
  95.  
  96. (defmethod (setf contact-foreground) :after (value (self scroll-frame))
  97.   (declare (ignore value))
  98.   (with-slots (foreground) self
  99.     (let ((hscroller (scroll-frame-hscroller self))
  100.       (vscroller (scroll-frame-vscroller self)))
  101.       (when hscroller
  102.     (setf (contact-foreground hscroller) foreground))
  103.       (when vscroller
  104.     (setf (contact-foreground vscroller) foreground)))
  105.     
  106.     (setf (window-border (scroll-frame-area self)) foreground)))
  107.  
  108.  
  109. (defmethod (setf scroll-frame-vertical) (value (self scroll-frame))
  110.   (with-slots (foreground top vertical) self
  111.     (setf vertical value)
  112.     
  113.     (let ((vscroller (scroll-frame-vscroller self))
  114.       (content   (scroll-frame-content self)))
  115.       
  116.       (ecase value
  117.     (:on
  118.      (if vscroller
  119.          ;; Map existing scroller
  120.          (setf (contact-state vscroller) :mapped)
  121.  
  122.          (progn
  123.            ;; Create a new scroller
  124.            (setf vscroller (make-scroller :parent self
  125.                           :name :vscroller
  126.                           :foreground foreground
  127.                           :border-width 0
  128.                           :orientation :vertical))
  129.            
  130.            ;; Program scroller to scroll content
  131.            (add-callback vscroller :new-value
  132.                  #'(lambda (new-top scroll-frame) 
  133.                  (with-slots (left top) scroll-frame
  134.                    (unless (= new-top top)
  135.                      (sf-scroll-to
  136.                        scroll-frame
  137.                        left
  138.                        (setf top new-top)))))
  139.                  self)))
  140.  
  141.      ;; Calibrate scroller with current content
  142.      (when content              
  143.        (sf-vertical-calibrate
  144.          content vscroller top (contact-height (scroll-frame-area self)))))
  145.     
  146.     (:off
  147.      (when vscroller
  148.        (setf (contact-state vscroller) :withdrawn)))))
  149.  
  150.     value))
  151.  
  152.  
  153. (defmethod (setf scroll-frame-horizontal) (value (self scroll-frame))
  154.   (with-slots (foreground left horizontal) self
  155.     (setf horizontal value)
  156.  
  157.     (let ((hscroller (scroll-frame-hscroller self))
  158.       (content   (scroll-frame-content self)))
  159.       
  160.       (ecase value
  161.     (:on
  162.      (if hscroller
  163.          ;; Map existing scroller
  164.          (setf (contact-state hscroller) :mapped)
  165.  
  166.          (progn
  167.            ;; Create a new scroller
  168.            (setf hscroller (make-scroller :parent self
  169.                           :name :hscroller
  170.                           :foreground foreground
  171.                           :border-width 0
  172.                           :orientation :horizontal))
  173.            
  174.            ;; Program scroller to scroll content
  175.            (add-callback hscroller :new-value
  176.                  #'(lambda (new-left scroll-frame) 
  177.                  (with-slots (left top) scroll-frame
  178.                    (unless (= new-left left)
  179.                      (sf-scroll-to
  180.                        scroll-frame
  181.                        (setf left new-left)
  182.                        top))))
  183.                  self)))
  184.      
  185.      ;; Calibrate scroller with current content
  186.      (when content       
  187.        (sf-horizontal-calibrate
  188.          content hscroller left (contact-width (scroll-frame-area self)))))
  189.     
  190.     (:off
  191.      (when hscroller
  192.        (setf (contact-state hscroller) :withdrawn)))))
  193.  
  194.     value))
  195.  
  196.  
  197. (defmethod scroll-frame-position ((self scroll-frame))
  198.   (with-slots (left top) self
  199.     (values left top)))
  200.  
  201. (defmethod scroll-frame-reposition ((self scroll-frame) &key left top)
  202.   "Changes the horizontal/vertical position of the content (in content
  203. units) which appears at the left/top edge of the scroll-frame.  The
  204. final content position (possibly adjusted via :horizontal-adjust and
  205. :vertical-adjust callbacks) is returned."
  206.   (with-slots ((current-left left) (current-top top) vertical horizontal) self
  207.     (let*
  208.       ((content        (scroll-frame-content   self))
  209.        (left-changed-p (and
  210.              left
  211.              (/= (setf left (apply-callback-else (content :horizontal-adjust left) left))
  212.                  current-left)))
  213.        (top-changed-p  (and
  214.              top
  215.              (/= (setf top (apply-callback-else (content :vertical-adjust top) top))
  216.                  current-top))))
  217.       (when left-changed-p
  218.     (setf current-left left)
  219.     (when (eq :on horizontal)
  220.       (setf (scale-value (scroll-frame-hscroller self)) current-left)))
  221.       
  222.       (when top-changed-p
  223.     (setf current-top top)
  224.     (when (eq :on vertical)
  225.       (setf (scale-value (scroll-frame-vscroller self)) current-top)))
  226.       
  227.       (when (or left-changed-p top-changed-p)
  228.     ;; Redisplay content at new position
  229.     (sf-scroll-to self current-left current-top))
  230.     
  231.     (values current-left current-top))))
  232.  
  233.  
  234.  
  235. (defun sf-scroll-to (scroll-frame left top)
  236.   (let ((content (scroll-frame-content scroll-frame)))
  237.     (when content
  238.       (apply-callback-else (content :scroll-to left top)
  239.     
  240.     ;; Default scrolling by moving content window w.r.t area.
  241.     ;; Content units are n pixels, where n is determined from
  242.     ;; pixels-per-unit used to calibrate scroller indicator size.
  243.     (let ((hscroller (scroll-frame-hscroller scroll-frame))
  244.           (vscroller (scroll-frame-vscroller scroll-frame))
  245.           (area      (scroll-frame-area scroll-frame)))        
  246.       (with-state (content)
  247.         (move content
  248.           (- (pixel-round (if hscroller
  249.                       (/ (* left (contact-width area))
  250.                      (scale-indicator-size hscroller))
  251.                       left)))
  252.           (- (pixel-round (if vscroller
  253.                       (/ (* top (contact-height area))
  254.                      (scale-indicator-size vscroller))
  255.                       top))))))))))
  256.  
  257.  
  258.  
  259. (defun sf-horizontal-calibrate (content hscroller left width)        
  260.   ;; Program scroller to adjust value
  261.   (add-callback hscroller :adjust-value
  262.         #'(lambda (value content)
  263.             (or (when content
  264.               (apply-callback content :horizontal-adjust value))
  265.             value))
  266.         content)
  267.   
  268.   ;; Update scroller values
  269.   (multiple-value-bind (min max ppu)
  270.       (apply-callback-else (content :horizontal-calibrate)
  271.     (values 0 (max 0 (- (contact-width content) width)) 1))
  272.     
  273.     ;; Clamp current left to new range
  274.     (let ((value (min max left)))
  275.       (scale-update hscroller
  276.             :value          value
  277.             :minimum        min
  278.             :maximum        max
  279.             :indicator-size (/ width ppu)
  280.             :increment      1)
  281.  
  282.       ;; Returned clamped value
  283.       value)))
  284.  
  285. (defun sf-vertical-calibrate (content vscroller top height)
  286.   ;; Program scroller to adjust value
  287.   (add-callback vscroller :adjust-value
  288.         #'(lambda (value content)
  289.             (or (when content
  290.               (apply-callback content :vertical-adjust value))
  291.             value))
  292.         content)
  293.   
  294.   ;; Update scroller values
  295.   (multiple-value-bind (min max ppu)
  296.       (apply-callback-else (content :vertical-calibrate)
  297.     (values 0 (max 0 (- (contact-height content) height)) 1))
  298.     (let ((value (min max top)))
  299.       (scale-update vscroller
  300.             :value          value
  301.             :minimum        min
  302.             :maximum        max
  303.             :indicator-size (/ height ppu)
  304.             :increment      1)
  305.       
  306.       ;; Return clamped value
  307.       value))) 
  308.  
  309.  
  310.  
  311. ;;;----------------------------------------------------------------------------+
  312. ;;;                                                                            |
  313. ;;;                         Geometry Management                                |
  314. ;;;                                                                            |
  315. ;;;----------------------------------------------------------------------------+
  316.  
  317. (defmethod change-layout ((self scroll-frame) &optional newly-managed)
  318.   (declare (ignore newly-managed))
  319.   (with-slots (width height horizontal vertical) self
  320.     
  321.     ;; Is initial scroll-frame size still undefined?
  322.     (if (unless (realized-p self) (or (zerop width) (zerop height)))
  323.     
  324.     ;; Yes, change to valid initial size (this invokes change-layout again)
  325.     (multiple-value-bind (preferred-width preferred-height)
  326.         (preferred-size self)
  327.       (change-geometry
  328.         self :width preferred-width :height preferred-height :accept-p t))
  329.     
  330.     ;; No, update layout for valid size.      
  331.     (let*
  332.       ((hscroller (when (eq :on horizontal) (scroll-frame-hscroller self)))
  333.        (vscroller (when (eq :on vertical)   (scroll-frame-vscroller self)))
  334.        (area      (scroll-frame-area   self))
  335.        (hheight   (if hscroller (contact-height hscroller) 0))        
  336.        (vwidth    (if vscroller (contact-width  vscroller) 0))
  337.        (hwidth    (max 0 (- width vwidth)))
  338.        (vheight   (max 0 (- height hheight)))        
  339.        (abw       (* 2 (contact-border-width area))))
  340.       
  341.       ;; Lay out scrollers
  342.       (when hscroller
  343.         (with-state (hscroller)
  344.           (resize hscroller hwidth hheight 0)
  345.           (move hscroller 0 (- height hheight))))
  346.       (when vscroller
  347.         (with-state (vscroller)
  348.           (resize vscroller vwidth vheight 0)
  349.           (move vscroller (- width vwidth) 0)))
  350.       
  351.       ;; Layout scroll area
  352.       (with-state (area)
  353.         (resize area
  354.             (max 0 (- width vwidth abw))
  355.             (max 0 (- height hheight abw))
  356.             (contact-border-width area))
  357.         (move area 0 0))
  358.       ))))
  359.  
  360. (defmethod manage-geometry ((self scroll-frame) child x y width height border-width &key)  
  361.   
  362.   (case (contact-name child)
  363.     (:scroll-area     
  364.      ;; Approve if total outside size/position remains unchanged.
  365.      (let* ((approved-bw     (or border-width (contact-border-width child)))
  366.         (delta-bw        (* 2 (- (contact-border-width child) approved-bw)))     
  367.         (approved-x      0)
  368.         (approved-y      0)
  369.         (approved-width  (+ (contact-width child) delta-bw))
  370.         (approved-height (+ (contact-height child) delta-bw)))
  371.        
  372.        
  373.        (values
  374.      (when
  375.        ;; Change approved?
  376.        (and
  377.          (or (null x)      (= x approved-x))
  378.          (or (null y)      (= y approved-y))
  379.          (or (null width)  (= width approved-width))
  380.          (or (null height) (= height approved-height))
  381.          (= border-width approved-bw))
  382.        
  383.        ;; Yes, update layout if change is performed      
  384.        'change-layout)
  385.      approved-x
  386.      approved-y
  387.      approved-width
  388.      approved-height
  389.      approved-bw)))
  390.  
  391.     (otherwise
  392.      ;; Approve any scroller size change. This should happen only during rescale.
  393.      (values
  394.        (when
  395.      (and 
  396.        (or (null border-width) (= border-width (contact-border-width child)))
  397.        (or (null x)            (= x (contact-x child)))
  398.        (or (null y)            (= y (contact-y child))))
  399.      'change-layout)
  400.        (contact-x child)
  401.        (contact-y child)
  402.        (or width (contact-width child))
  403.        (or height (contact-height child))
  404.        (contact-border-width child)))))
  405.  
  406. (defmethod preferred-size ((self scroll-frame) &key width height border-width)  
  407.   (with-slots ((self-width width) (self-height height) (self-border-width border-width)) self
  408.  
  409.     (let ((suggested-width        (or width self-width))
  410.       (suggested-height       (or height self-height))
  411.       (suggested-border-width (or border-width self-border-width)))
  412.       (values
  413.     (if (plusp suggested-width)
  414.         suggested-width
  415.         (let ((content   (scroll-frame-content self))
  416.           (hscroller (scroll-frame-hscroller self))
  417.           (vscroller (scroll-frame-vscroller self)))
  418.           (+ (max (if content   (contact-width content)   0)
  419.               (if hscroller (contact-width hscroller) 0))
  420.          (if vscroller (contact-width vscroller) 0))))
  421.  
  422.     (if (plusp suggested-height)
  423.         suggested-height
  424.         (let ((content   (scroll-frame-content self))
  425.           (hscroller (scroll-frame-hscroller self))
  426.           (vscroller (scroll-frame-vscroller self)))
  427.           (+ (max (if content   (contact-height content)   0)
  428.               (if vscroller (contact-height vscroller) 0))
  429.            (if hscroller (contact-height hscroller) 0))))
  430.     suggested-border-width ))))
  431.  
  432. (defmethod resize :after ((self scroll-frame) new-width new-height new-border-width)
  433.   (declare (ignore new-width new-height new-border-width))
  434.   (change-layout self)) 
  435.  
  436. (defmethod add-child :before ((self scroll-frame) child &key)
  437.   (assert (member (contact-name child) '(:hscroller :vscroller :scroll-area) :test #'eq) ()
  438.       "A scroll-frame does not allow you to define new children."))
  439.  
  440.  
  441.  
  442.  
  443. ;;;----------------------------------------------------------------------------+
  444. ;;;                                                                            |
  445. ;;;                            Initialization                                  |
  446. ;;;                                                                            |
  447. ;;;----------------------------------------------------------------------------+
  448.  
  449.  
  450. (defun make-scroll-frame (&rest initargs)
  451.   (apply #'make-contact 'scroll-frame initargs))
  452.     
  453.  
  454. (defmethod initialize-instance :after ((self scroll-frame) &key content &allow-other-keys)
  455.   (with-slots (foreground vertical horizontal) self
  456.     (let (;; Create scroll area
  457.       (area (make-contact 'scroll-area
  458.                   :parent self
  459.                   :name :scroll-area
  460.                   :border-width 1
  461.                   :border foreground)))
  462.       ;; Create content, if given.
  463.       (when content
  464.     (multiple-value-bind (content-constructor content-initargs)
  465.         (etypecase content
  466.           (function content) 
  467.           (list (values (first content) (rest content))))
  468.         
  469.       (apply content-constructor
  470.          :name (or (getf content-initargs :name) :content)
  471.          :parent area
  472.          content-initargs))))
  473.     
  474.     ;; Initialize scroll bars
  475.     (setf (scroll-frame-horizontal self) horizontal)
  476.     (setf (scroll-frame-vertical self) vertical)))
  477.  
  478.  
  479.  
  480.  
  481. ;;;----------------------------------------------------------------------------+
  482. ;;;                                                                            |
  483. ;;;                             Scroll Area                                    |
  484. ;;;                                                                            |
  485. ;;;----------------------------------------------------------------------------+
  486.  
  487.  
  488.  
  489. (defcontact scroll-area (composite) ()
  490.   (:documentation "Geometry manager for the scroll area of a scroll frame."))
  491.  
  492.  
  493. ;;; Geometry management policy:
  494. ;;;     1. Content border width forced to 0. This prevents the bottom/right edges
  495. ;;;        of a small content from intruding.
  496. ;;;     2. Content size and position is unrestricted.
  497. ;;;     3. Only one content child allowed.
  498.  
  499. (defmethod add-child :before ((self scroll-area) child &key)
  500.   (declare (ignore child))
  501.   (assert (not (composite-children self)) ()
  502.       "A scroll area can have only one child."))
  503.     
  504. (defmethod change-layout ((self scroll-area) &optional newly-managed)
  505.   (declare (ignore newly-managed))
  506.   (with-slots (children (scroll-frame parent) width height) self
  507.     (let ((content (first children)))
  508.       (when content
  509.     ;; If realized, then recalibrate scrollers for new content
  510.     ;; (otherwise, not necessary since initial calibration will be done
  511.     ;; after initial scroll-area size is set).
  512.     (when (realized-p self)
  513.       (sf-recalibrate scroll-frame))
  514.  
  515.     ;; Define content callbacks used by application to report new calibration data
  516.     (flet
  517.       ((horizontal-update
  518.          (&key position minimum maximum pixels-per-unit scroll-frame)
  519.          
  520.          ;; Recalibrate scroller, if necessary
  521.          (when (eq :on (scroll-frame-horizontal scroll-frame))
  522.            (scale-update
  523.          (scroll-frame-hscroller scroll-frame)
  524.          :value          position
  525.          :minimum        minimum
  526.          :maximum        maximum
  527.          :indicator-size (when pixels-per-unit
  528.                    (/ (contact-width (scroll-frame-area scroll-frame))
  529.                       pixels-per-unit))))
  530.          
  531.          ;; Update current scroll-frame position
  532.          (when position
  533.            (with-slots (left top) scroll-frame
  534.            (sf-scroll-to
  535.          scroll-frame
  536.          (setf left position)
  537.          top))))
  538.        
  539.        (vertical-update
  540.          (&key position minimum maximum pixels-per-unit scroll-frame)
  541.          
  542.          ;; Recalibrate scroller, if necessary
  543.          (when (eq :on (scroll-frame-vertical scroll-frame))
  544.            (scale-update
  545.          (scroll-frame-vscroller scroll-frame)
  546.          :value          position
  547.          :minimum        minimum
  548.          :maximum        maximum
  549.          :indicator-size (when pixels-per-unit
  550.                    (/ (contact-height (scroll-frame-area scroll-frame))
  551.                       pixels-per-unit))))
  552.          
  553.          ;; Update current scroll-frame position
  554.          (when position
  555.            (with-slots (left top) scroll-frame
  556.          (sf-scroll-to
  557.            scroll-frame
  558.            left
  559.            (setf top position))))))
  560.         
  561.       (add-callback content :horizontal-update
  562.             #'horizontal-update
  563.             :scroll-frame scroll-frame)
  564.       (add-callback content :vertical-update
  565.             #'vertical-update
  566.             :scroll-frame scroll-frame))
  567.  
  568.     ;; Initialize content
  569.     (with-state (content)
  570.       ;; Initialize content position (this may be changed later if
  571.       ;; default pixel scrolling is used)
  572.       (move content 0 0)
  573.       
  574.       ;; Force content border width to 0
  575.       (with-slots
  576.         ((content-width width) (content-height height)) content
  577.         (resize content content-width content-height 0)))))))
  578.  
  579.  
  580.  
  581. (defmethod manage-geometry ((self scroll-area) content x y width height border-width &key)
  582.   (flet
  583.     ((update-scroller-maximum
  584.       (scroll-area)
  585.       ;; Called when an approved content geometry change is performed. When default
  586.       ;; scrolling is used, then scrollers must be updated to reflect new
  587.       ;; pixel size of content w.r.t scroll-area. 
  588.       (let ((content (first (composite-children scroll-area))))
  589.     ;; Default scrolling?
  590.     (unless (callback-p content :scroll-to)
  591.       (let
  592.         ((frame (contact-parent scroll-area))
  593.          (max-h (max 0 (- (contact-width content) (contact-width scroll-area))))
  594.          (max-v (max 0 (- (contact-height content) (contact-height scroll-area)))))       
  595.         (apply-callback
  596.           content :horizontal-update
  597.           :maximum  max-h
  598.           :position (min (scroll-frame-left frame) max-h))
  599.         (apply-callback
  600.           content :vertical-update
  601.           :maximum  max-v
  602.           :position (min (scroll-frame-top frame) max-v)))))))
  603.               
  604.     (values
  605.       (when (or (null border-width) (= border-width 0))
  606.     #'update-scroller-maximum)
  607.       (or x (contact-x content))
  608.       (or y (contact-y content))
  609.       (or width (contact-width content))
  610.       (or height (contact-height content))
  611.       0)))    
  612.  
  613.  
  614. (defmethod resize :after ((self scroll-area) new-width new-height new-bw)
  615.   (declare (ignore  new-width new-height new-bw))
  616.   (with-slots (parent) self
  617.     (let ((scroll-frame parent))
  618.       
  619.       (sf-recalibrate scroll-frame)
  620.       
  621.       (unless (realized-p self)      
  622.     ;; Move content into initial position, now that content units have been
  623.     ;; defined.
  624.     (sf-scroll-to
  625.       scroll-frame
  626.       (scroll-frame-left scroll-frame)
  627.       (scroll-frame-top scroll-frame))))))
  628.   
  629. (defun sf-recalibrate (scroll-frame)
  630.   (let ((content (scroll-frame-content scroll-frame)))
  631.     
  632.     (when content      
  633.       (with-slots (left top horizontal vertical) scroll-frame
  634.     (with-slots (width height) (scroll-frame-area scroll-frame)
  635.  
  636.       (let ((new-left left) (new-top top))
  637.         (let ((hscroller (when (eq :on horizontal) (scroll-frame-hscroller scroll-frame))))
  638.           (when hscroller
  639.         (setf new-left (sf-horizontal-calibrate content hscroller left width))))
  640.         
  641.         (let ((vscroller (when (eq :on vertical) (scroll-frame-vscroller scroll-frame))))
  642.           (when vscroller
  643.         (setf new-top (sf-vertical-calibrate content vscroller top height))))
  644.  
  645.         (scroll-frame-reposition scroll-frame :left new-left :top new-top)))))))
  646.  
  647.